home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / t3_1 / risc_src.lha / risc_sources / comp / primops / foo < prev    next >
Encoding:
Text File  |  1989-06-30  |  5.4 KB  |  185 lines
  1. (herald mipsgenarith
  2.   (env tsys (t3_primops open) (t3_primops aliases)))
  3.  
  4. (define-constant (add . args)         
  5.   (iterate loop ((args args) (res '0))
  6.     (if (null? args)
  7.         res
  8.         (loop (cdr args) (%add (car args) res)))))
  9.  
  10. (declare simplifier add
  11.   (lambda (call)
  12.     (let ((args (cdr (call-args call))))
  13.       (cond ((null? args)
  14.              (replace-call-with-value call (create-literal-node '0))
  15.              '#t)
  16.             ((null? (cdr args))  ; (+ 'a) => 'a in compiled code - no checking
  17.              (replace-call-with-value call (detach (car args)))
  18.              '#t)
  19.             (else
  20.              (n-ary->binary call '%add))))))
  21.  
  22. (define-constant (%add x y)
  23.   (let ((generic (lambda (x y) (%%add x y))))
  24.     (receive (ok? arg1 arg2)
  25.              (two-fixnums x y)
  26.       (if ok?
  27.           (receive (over? result)
  28.                    (fixnum-add-with-overflow arg1 arg2)
  29.             (if over? (generic x y) result))
  30.           (generic x y)))))
  31.  
  32. ;;; SUBTRACT
  33.  
  34. (define-constant (subtract x y)
  35.   (let ((generic (lambda (x y) (%%subtract x y))))
  36.     (receive (ok? arg1 arg2)
  37.              (two-fixnums x y)
  38.       (if ok?
  39.           (receive (over? result)
  40.                    (fixnum-subtract-with-overflow arg1 arg2)
  41.             (if over? (generic x y) result))
  42.           (generic x y)))))
  43.  
  44. ;;; MULTIPLY
  45.  
  46. (define-constant (multiply . args)    ; must be CONSTANT to get simplifier
  47.   (iterate loop ((args args) (res '1))
  48.     (if (null? args)
  49.         res
  50.         (loop (cdr args) (%multiply (car args) res)))))
  51.  
  52. (declare simplifier multiply
  53.   (lambda (call)
  54.     (let ((args (cdr (call-args call))))
  55.       (cond ((null? args)
  56.              (replace-call-with-value call (create-literal-node '1))
  57.              '#t)
  58.             ((null? (cdr args))  ; (* 'a) => 'a in compiled code - no checking
  59.              (replace-call-with-value call (detach (car args)))
  60.              '#t)
  61.             (else
  62.              (n-ary->binary call '%multiply)))))) 
  63.  
  64. (define-constant (%multiply x y)
  65.   (let ((generic (lambda (x y) (%%multiply x y))))
  66.     (receive (ok? arg1 arg2)
  67.              (two-fixnums x y)
  68.       (if ok?
  69.           (receive (over? result)
  70.                    (fixnum-multiply-with-overflow arg1 arg2)
  71.             (if over? (generic x y) result))
  72.           (generic x y)))))
  73.  
  74. (define-constant (remainder x y)
  75.   (receive (ok? arg1 arg2)
  76.            (two-fixnums x y)
  77.     (if ok?
  78.         (fixnum-remainder arg1 arg2)   ; no overflow possible
  79.         (%%remainder x y))))
  80.  
  81. (define-constant (logand x y)
  82.   (receive (ok? arg1 arg2)
  83.            (two-fixnums x y)
  84.     (if ok?
  85.         (fixnum-logand arg1 arg2)   ; no overflow possible
  86.         (%%logand x y))))
  87.  
  88. (define-constant (logior x y)
  89.   (receive (ok? arg1 arg2)
  90.            (two-fixnums x y)
  91.     (if ok?
  92.         (fixnum-logior arg1 arg2)   ; no overflow possible
  93.         (%%logior x y))))
  94.  
  95. (define-constant (logxor x y)
  96.   (receive (ok? arg1 arg2)
  97.            (two-fixnums x y)
  98.     (if ok?
  99.         (fixnum-logxor arg1 arg2)   ; no overflow possible
  100.         (%%logxor x y))))
  101.  
  102. (define-constant (lognot x)
  103.   (logxor x -1))
  104.  
  105. ;;; LESS?
  106.  
  107. (define-constant (less? x y)
  108.   (if (two-fixnums-for-compare? x y)
  109.       (fx< x y)
  110.       (%%less? x y)))
  111.  
  112. ;;; NUMBER-EQUAL?
  113.  
  114. (define-constant (number-equal? x y)
  115.   (if (two-fixnums-for-compare? x y)
  116.       (fx= x y)
  117.       (%%equal? x y)))
  118.  
  119. ;;; Thousands of random ways to call the above
  120.  
  121. (define-constant (negate x) (subtract 0 x))
  122.  
  123. (define-constant + add)
  124.  
  125. (define-constant (- x . y)            ; must be CONSTANT to get simplifier
  126.   (cond ((null? y) (negate x))
  127.         ((null? (cdr y)) (subtract x (car y)))
  128.         (else (error "wrong number of arguments to procedure~%  ~S"
  129.              `(- ,x . ,y)))))
  130.  
  131. (declare simplifier -
  132.   (lambda (call)
  133.     (let ((args (cdr (call-args call))))
  134.       (cond ((null? args)
  135.              (user-message 'warning "- called with no arguments" '#f)
  136.              '#f)       ; Error at runtime
  137.             ((null? (cdr args))
  138.              (replace (call-proc call)
  139.                       (create-reference-node (get-system-variable 'negate)))
  140.              '#t)
  141.             ((null? (cddr args))
  142.              (replace (call-proc call)
  143.                       (create-reference-node (get-system-variable 'subtract))))
  144.             (else
  145.              (user-message 'warning "more than two arguments in a call to -" '#f)
  146.              '#f)))))   ; Error at runtime
  147.  
  148.  
  149. (define-constant * multiply)
  150.  
  151. (define-constant (add1      x) (%add     x 1))
  152. (define-constant (subtract1 x) (subtract x 1))
  153.  
  154. (define-constant  1+ add1)
  155. (define-constant -1+ subtract1)
  156. (define-constant (=1? x) (= x 1))
  157.  
  158. (define-constant (not-less? x y)         (not (less? x y)))
  159. (define-constant (number-not-equal? x y) (not (number-equal? x y)))
  160. (define-constant (greater? x y)          (less? y x))
  161. (define-constant (not-greater? x y)      (not (less? y x)))
  162.  
  163. (define-constant <  less?)
  164. (define-constant <= not-greater?)
  165. (define-constant =  number-equal?)
  166. (define-constant N= number-not-equal?)
  167. (define-constant >  greater?)
  168. (define-constant >= not-less?)
  169.  
  170. (define-constant (negative? x)     (< x 0))
  171. (define-constant (zero? x)         (= x 0))
  172. (define-constant (positive? x)     (> x 0))
  173. (define-constant (not-negative? x) (>= x 0))
  174. (define-constant (not-zero? x)     (N= x 0))
  175. (define-constant (not-positive? x) (<= x 0))
  176.  
  177. (define-constant <0?  negative?)
  178. (define-constant =0?  zero?)
  179. (define-constant >0?  positive?)
  180. (define-constant >=0? not-negative?)
  181. (define-constant n=0? not-zero?)
  182. (define-constant <=0? not-positive?)
  183.  
  184.  
  185.